home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Tech Arsenal 1
/
Tech Arsenal (Arsenal Computer).ISO
/
tek-02
/
lbargen.zip
/
LBARGEN.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1993-01-04
|
7KB
|
251 lines
const
start_char = 64;
spaces = ' ';
var
x,y : integer;
menu_items : array[1..20] of string[40];
menu_choices : array[1..20] of string[ 8];
outfile : text;
filename : string[8];
menu_title : string[40];
proc_title : string[8];
need_proc : boolean;
ch : char;
procedure get_file_name;
begin
ClrScr;
gotoXY(10,10); write('Enter file name [no extent] :'); read(filename);
assign(outfile,filename+'.PRG');
rewrite(outfile);
ClrScr;
gotoXY(10,10); write('Enter the title for this menu');
gotoXY(6,12); write('[________________________________________]');
gotoXY(7,12); read(menu_title);
if length(menu_title) < 40 then
menu_title:=copy(spaces,1,(40-length(menu_title)) div 2) + menu_title +
copy(spaces,1,(40-length(menu_title)) div 2);
if length(menu_title) < 40 then
menu_title:=menu_title+' ';
if length(menu_title) < 40 then
menu_title:=' '+menu_title;
ClrScr;
gotoXY(10, 8);
write('Is there a procedure file asscoiated with this menu: ');
read(kbd,ch);
if ch in ['y','Y'] then need_proc:=true else need_proc := false;
if need_proc then
begin
gotoXY(10,10);
write('Enter file name [no extent] :'); read(proc_title);
end;
end;
procedure get_munu_items;
begin
ClrScr;
gotoXY(10,1); write('How many menu items for this menu: '); read(x);
for y := 1 to x do
begin
gotoXY(5,2+y); write('[________________________________________]');
end;
for y:= 1 to x do
begin
gotoXY(6,2+y); read(menu_items[y]);
menu_items[y]:=copy(menu_items[y],1,length(menu_items[y]))+
copy(spaces,1,40-length(menu_items[y]));
end;
end;
procedure show_menu_items;
begin
ClrScr;
for y := 1 to x do
begin
gotoXY(5,y+2); write('[',chr(start_char+y),'] ',menu_items[y]);
end;
end;
procedure get_choices;
begin
gotoXY(5,1); write('Enter command file to call for each menu choice: ');
for y:= 1 to x do
begin
gotoXY(50,y+2); write('[________]');
end;
for y:=1 to x do
begin
gotoXY(51,y+2); read(menu_choices[y]);
end;
end;
procedure write_outfile;
var
z,
add_line,
box_size,
box_start : integer;
begin
writeln(outfile,'SET TALK OFF');
writeln(outfile,'SET STATUS OFF');
writeln(outfile,'SET SCOREBOARD OFF');
if need_proc then
writeln(outfile,'SET PROCEDURE TO ',proc_title);
writeln(outfile,'STORE .T. TO more');
writeln(outfile,'DO WHILE more');
writeln(outfile,' RELEASE ALL');
writeln(outfile,' CLOSE DATABASES');
writeln(outfile,' CLOSE INDEX');
writeln(outfile,' SET BELL OFF');
writeln(outfile,' SET DEVICE TO SCREEN');
writeln(outfile,' SET PRINT OFF');
writeln(outfile,' SET TALK OFF');
writeln(outfile,' x=',x:2);
for y := 1 to x do
begin
write(outfile,' title');
if y < 10 then
write(outfile,y:1)
else
write(outfile,y:2);
writeln(outfile,' = "','[',chr(start_char+y),'] ',menu_items[y],'"');
end;
write(outfile,' title');
if y < 10 then
write(outfile,y+1:1)
else
write(outfile,y+1:2);
writeln(outfile,' = "[X] Exit "');
writeln(outfile,' ChoiceNum = ',x+1:2);
writeln(outfile,' CLEAR');
writeln(outfile,' CHOICE=1');
writeln(outfile,' menutitle = " ',menu_title,' "');
if x > 9 then add_line :=1 else add_line := 2;
writeln(outfile,' SET COLOR TO n/w');
box_size := x*add_line+2;
box_start:= (24 - box_size) div 2;
writeln(outfile,' @ ',box_start-1:2,',15 SAY menutitle');
writeln(outfile,' SET COLOR TO w/n');
writeln(outfile,' @ ',box_start:2,',15 TO ',
box_start+box_size:2,',65 DOUBLE');
y := box_start+1;
z:=1;
repeat
if z=1 then writeln(outfile,' SET COLOR TO n/w');
write(outfile,' @ ',y:2,',19 say Title');
if z < 10 then
writeln(outfile,z:1)
else
writeln(outfile,z:2);
if z=1 then writeln(outfile,' SET COLOR TO w/n');
y:=y+add_line;
z:=z+1;
until z > x;
write(outfile,' @ ',y:2,',19 say Title');
if z < 10 then
writeln(outfile,z:1)
else
writeln(outfile,z:2);
writeln(outfile,' MenuLoop=.T.');
writeln(outfile,' Upkey = 5');
writeln(outfile,' DownKey = 24');
writeln(outfile,' ReturnKey = 13');
writeln(outfile,' key = 0');
writeln(outfile,' DO WHILE MenuLoop');
writeln(outfile,' PChoice = Choice');
writeln(outfile,' DO WHILE key = 0');
writeln(outfile,' key=INKEY()');
writeln(outfile,' ENDDO');
writeln(outfile,' DO CASE');
writeln(outfile,' CASE key=88.OR. key = 120');
writeln(outfile,' RETURN');
writeln(outfile,' CASE key=ReturnKey');
writeln(outfile,' MenuLoop=.F.');
writeln(outfile,' LOOP');
writeln(outfile,' CASE key > 96 .AND. key < ChoiceNum+97');
writeln(outfile,' Choice = key - 96');
writeln(outfile,' MenuLoop = .F.');
writeln(outfile,' LOOP');
writeln(outfile,' CASE key > 64 .AND. key < ChoiceNum+65');
writeln(outfile,' Choice = key - 64');
writeln(outfile,' MenuLoop = .F.');
writeln(outfile,' LOOP');
writeln(outfile,' CASE key=UpKey .and. Choice > 1');
writeln(outfile,' Choice = Choice - 1');
writeln(outfile,' CASE key=DownKey .and. Choice < ChoiceNum');
writeln(outfile,' Choice = Choice + 1');
writeln(outfile,' ENDCASE');
writeln(outfile,' SET COLOR TO w/n');
writeln(outfile,' DO CASE');
y := box_start+1;
z:=1;
repeat
writeln(outfile,' CASE PChoice =',z:2);
write(outfile,' @ ',y:2,',19 say Title');
if z < 10 then
writeln(outfile,z:1)
else
writeln(outfile,z:2);
y:=y+add_line;
z:=z+1;
until z > x;
writeln(outfile,' CASE PChoice =',z:2);
write(outfile,' @ ',y:2,',19 say Title');
if z < 10 then
writeln(outfile,z:1)
else
writeln(outfile,z:2);
writeln(outfile,' ENDCASE');
writeln(outfile,' SET COLOR TO n/w');
writeln(outfile,' DO CASE');
y := box_start+1;
z:=1;
repeat
writeln(outfile,' CASE Choice =',z:2);
write(outfile,' @ ',y:2,',19 say Title');
if z < 10 then
writeln(outfile,z:1)
else
writeln(outfile,z:2);
y:=y+add_line;
z:=z+1;
until z > x;
writeln(outfile,' CASE Choice =',z:2);
write(outfile,' @ ',y:2,',19 say Title');
if z < 10 then
writeln(outfile,z:1)
else
writeln(outfile,z:2);
writeln(outfile,' ENDCASE');
writeln(outfile,' SET COLOR TO w/n');
writeln(outfile,' key=0');
writeln(outfile,' ENDDO');
writeln(outfile,' DO CASE ');
for y:= 1 to x do
begin
writeln(outfile,' CASE Choice =',y:2);
writeln(outfile,' DO ',menu_choices[y]);
end;
writeln(outfile,' CASE Choice = ChoiceNum');
writeln(outfile,' RETURN');
writeln(outfile,' ENDCASE');
writeln(outfile,'ENDDO');
writeln(outfile,'RETURN');
close(outfile);
end;
begin
get_file_name;
get_munu_items;
show_menu_items;
get_choices;
write_outfile;
end.